home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / !runtime / mosml.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-18  |  24.0 KB  |  1,131 lines  |  [TEXT/R*ch]
  1. /* Moscow SML primitives */
  2.  
  3. #include <math.h>
  4. #include <sys/time.h>
  5. #include <sys/times.h>
  6. #include <sys/resource.h>
  7. #include <dirent.h>
  8. #include <errno.h>
  9. #include <stdio.h>
  10. #include <stdlib.h>
  11. #include <sys/param.h> 
  12. #include <sys/stat.h>
  13. #include <time.h>
  14. #include <unistd.h>
  15. #include <utime.h>
  16. #include <ctype.h>
  17. #include "fail.h"
  18. #include "memory.h"
  19. #include "str.h"
  20. #include "runtime.h"
  21.  
  22. #if defined(sun) && !defined(__svr4__)
  23. #define tm2cal(tptr)    timelocal(tptr)
  24. #else
  25. #define tm2cal(tptr)    mktime(tptr)
  26. #endif
  27.  
  28. #define Raise_float_if(cond) \
  29.    if( cond ) \
  30.       { mlraise(Atom(float_exn)); }
  31.  
  32. #define Check_float(dval) \
  33.    Raise_float_if( (dval > maxdouble) || (dval < -maxdouble) )
  34.  
  35. /* Structural equality on trees. */
  36. /* Note how reference cells are treated! */
  37.  
  38. static int sml_equal_aux(v1, v2)
  39.      value v1,v2;
  40. {
  41.   mlsize_t i;
  42.   value * p1, * p2;
  43.  
  44.  again:
  45.   if (v1 == v2) return 1;
  46.   if (Is_long(v1) || Is_long(v2)) return 0;
  47.   if (!Is_in_heap(v1) && !Is_young(v1)) return 0;
  48.   if (!Is_in_heap(v2) && !Is_young(v2)) return 0;
  49.   if (Tag_val(v1) != Tag_val(v2)) return 0;
  50.   switch(Tag_val(v1)) {
  51.   case String_tag:
  52.     return (compare_strings(v1, v2) == Val_long(0));
  53.   case Double_tag:
  54.     return (Double_val(v1) == Double_val(v2));
  55.   case Reference_tag:  /* Different reference cells are not equal! */
  56.   case Abstract_tag:
  57.   case Final_tag:
  58.     return 0;
  59.   case Closure_tag:
  60.     invalid_argument("sml_equal: functional value");
  61.   default:
  62.     i = Wosize_val(v1);
  63.     if (i != Wosize_val(v2)) return 0;
  64.     for(p1 = Op_val(v1), p2 = Op_val(v2);
  65.         i > 1;
  66.         i--, p1++, p2++)
  67.       if (!sml_equal_aux(*p1, *p2)) return 0;
  68.     v1 = *p1;
  69.     v2 = *p2;                   /* Tail-call */
  70.     goto again;
  71.   }
  72. }
  73.  
  74. value sml_equal(v1, v2) /* ML */
  75.      value v1, v2;
  76. {
  77.   return Atom(sml_equal_aux(v1,v2));
  78. }
  79.  
  80. value sml_not_equal(v1, v2) /* ML */
  81.      value v1, v2;
  82. {
  83.   return Atom(!sml_equal_aux(v1,v2));
  84. }
  85.  
  86. value sml_system(cmd)        /* ML */
  87.      value cmd;
  88. {
  89.   return Val_int(system(String_val(cmd)));
  90. }
  91.  
  92. value sml_abs_int(x)          /* ML */
  93.     value x;
  94. { value tmp, v;
  95.   tmp = Long_val(x);
  96.   if( tmp < 0 ) tmp = -tmp;
  97.   v = Val_long(tmp);
  98.   if( Long_val(v) != tmp )
  99.     mlraise(Atom(SMLEXN_OVF));
  100.   return v;
  101. }
  102.  
  103. value sml_floor(f)              /* ML */
  104.      value f;
  105. { double r;
  106.   long i;
  107.   value v;
  108.   r = Double_val(f);
  109.   if( r >= 0.0 )
  110.     { if( r >= ((double) (Max_long+1)) ) goto raise_floor;
  111.       i = (long) r;
  112.     }
  113.   else
  114.     { if( r < ((double) Min_long) ) goto raise_floor;
  115.       i = (long) r;
  116.       if( r < ((double) i) ) i -= 1;
  117.     }
  118.   v = Val_long(i);
  119.   if( Long_val(v) != i )  goto raise_floor;
  120.   return v;
  121.  
  122. raise_floor:
  123.     mlraise(Atom(SMLEXN_OVF));
  124. }
  125.  
  126. value sml_ceil(f)              /* ML */
  127.      value f;
  128. { double r;
  129.   long i;
  130.   value v;
  131.   r = Double_val(f);
  132.   if( r >= 0.0 )
  133.     { if( r > ((double) (Max_long)) ) goto raise_ceil;
  134.       i = (long) r;
  135.       if( r > ((double) i) ) i += 1;
  136.     }
  137.   else
  138.     { if( r <= ((double) (Min_long-1)) ) goto raise_ceil;
  139.       i = (long) r;
  140.     }
  141.   v = Val_long(i);
  142.   if( Long_val(v) != i )  goto raise_ceil;
  143.   return v;
  144.  
  145. raise_ceil:
  146.     mlraise(Atom(SMLEXN_OVF));
  147. }
  148.  
  149. #ifdef __MWERKS__
  150. #include <Types.h>
  151. double_t nearbyint ( double_t x );
  152. #define rint nearbyint
  153. #endif
  154.  
  155. value sml_round(f)              /* ML */
  156.      value f;
  157. { double r;
  158.   long i;
  159.   value v;
  160.   /* Apparently no rint() in djgpp's libm: */
  161. #if defined(MSDOS) || defined(hpux)
  162.   r = Double_val(f);
  163.   if( r >= 0.0 )
  164.     { if( (r+0.5) >= ((double) (Max_long+1)) ) goto raise_round;
  165.       i = (long) (r+0.5);
  166.     }
  167.   else
  168.     { if( (r-0.5) < ((double) Min_long) ) goto raise_round;
  169.       i = (long) (r-0.5);
  170.     }
  171.   v = Val_long(i);
  172.   if( Long_val(v) != i )  goto raise_round;
  173. #else
  174.   r = rint(Double_val(f));
  175.   if ((r > (double) (Max_long)) || (r < (double)(Min_long))) goto raise_round;
  176.   i = (long) r;
  177.   v = Val_long(i);
  178. #endif
  179.  
  180.   return v;
  181.  
  182. raise_round:
  183.     mlraise(Atom(SMLEXN_OVF));
  184. }
  185.  
  186. value sml_trunc(f)              /* ML */
  187.      value f;
  188. { double r;
  189.   long i;
  190.   value v;
  191.   r = Double_val(f);
  192.   if ((r >= (double) (Max_long+1)) || (r <= (double)(Min_long-1))) 
  193.     goto raise_trunc;
  194.   i = (long) r;
  195.   v = Val_long(i);
  196.   return v;
  197.  
  198. raise_trunc:
  199.     mlraise(Atom(SMLEXN_OVF));
  200. }
  201.  
  202. value sml_abs_real(f)              /* ML */
  203.      value f;
  204. { double r;
  205.   float_exn = SMLEXN_OVF;
  206.   r = Double_val(f);
  207.   if( r >= 0.0 )
  208.     return f;
  209.   else
  210.     r = -r;
  211.     Check_float(r);
  212.     return copy_double(r);
  213. }
  214.  
  215. value sml_sqrt(f)         /* ML */
  216.      value f;
  217. { double r;
  218.   float_exn = SMLEXN_DOMAIN;
  219.   r = Double_val(f);
  220.   Raise_float_if( r < 0.0 );
  221.   r = sqrt(r);
  222.   Check_float(r);
  223.   return copy_double(r);
  224. }
  225.  
  226. value sml_sin(f)         /* ML */
  227.      value f;
  228. { double r;
  229.   r = Double_val(f);
  230.   r = sin(r);
  231.   if( r != r || r > 1.0 || r < -1.0 )
  232.     failwith("sin: argument too large");
  233.   return copy_double(r);
  234. }
  235.  
  236. value sml_cos(f)         /* ML */
  237.      value f;
  238. { double r;
  239.   r = Double_val(f);
  240.   r = cos(r);
  241.   if( r != r || r > 1.0 || r < -1.0 )
  242.     failwith("cos: argument too large");
  243.   return copy_double(r);
  244. }
  245.  
  246. value sml_exp(f)           /* ML */
  247.      value f;
  248. { double r;
  249.   float_exn = SMLEXN_OVF;
  250.   r = exp(Double_val(f));
  251.   Check_float(r);
  252.   return copy_double(r);
  253. }
  254.  
  255. value sml_ln(f)           /* ML */
  256.      value f;
  257. { double r;
  258.   float_exn = SMLEXN_DOMAIN;
  259.   r = Double_val(f);
  260.   Raise_float_if( r <= 0.0 );
  261.   r = log(r);
  262.   Check_float(r);
  263.   return copy_double(r);
  264. }
  265.  
  266. value scandec(p, max)
  267.      char *p;
  268.      unsigned long max;
  269. { unsigned long res;
  270.   int c, d;
  271.   res = 0;
  272.   while (1) {
  273.     c = *p;
  274.     if (c >= '0' && c <= '9')
  275.       d = c - '0';
  276.     else
  277.       break;
  278.     if( (res > (max/10)) ||
  279.         ((res == (max/10) && ((max % 10) <= d))) )
  280.       goto raise_failure;
  281.     res = 10 * res + d;
  282.     p++;
  283.   }
  284.   if (*p != 0)
  285.     goto raise_failure;
  286.   return res;
  287.  
  288.   raise_failure:
  289.     failwith("scandec");
  290. }
  291.  
  292. value scanhex(p, max)
  293.      char *p;
  294.      unsigned long max;
  295. { unsigned long res;
  296.   int c, d;
  297.   res = 0;
  298.   while (1) {
  299.     c = toupper(*p);
  300.     if (c >= '0' && c <= '9')
  301.       d = c - '0';
  302.     else if (c >= 'A' && c <= 'F')
  303.       d = c + (10 - 'A');
  304.     else
  305.       break;
  306.     if( (res > (max/16)) ||
  307.         ((res == (max/16) && ((max % 16) <= d))) )
  308.       goto raise_failure;
  309.     res = 16 * res + d;
  310.     p++;
  311.   }
  312.   if (*p != 0)
  313.     goto raise_failure;
  314.   return res;
  315.  
  316.   raise_failure:
  317.     failwith("scandec");
  318. }
  319.  
  320. value sml_int_of_string(s)          /* ML */
  321.      value s;
  322. { value v;
  323.   long res;
  324.   int sign;
  325.   char * p;
  326.  
  327.   p = String_val(s);
  328.   sign = 1;
  329.   if (*p == '~') {
  330.     sign = -1;
  331.     p++;
  332.   }
  333.   res = sign * scandec(p, (unsigned long)Min_long);
  334.   v = Val_long(res);
  335.   if( Long_val(v) != res )
  336.     goto raise_failure;
  337.   return v;
  338.  
  339.   raise_failure:
  340.     failwith("sml_int_of_string");
  341. }
  342.  
  343. value sml_concat(s1, s2)        /* ML */
  344.      value s1, s2;
  345. {
  346.   mlsize_t len1, len2, len;
  347.   value s;
  348.   Push_roots(r, 2);
  349.   r[0] = s1;
  350.   r[1] = s2;
  351.   len1 = string_length(s1);
  352.   len2 = string_length(s2);
  353.   len = len1 + len2;
  354.   if( (len + sizeof (value)) / sizeof (value) > Max_wosize )
  355.     mlraise(Atom(END_OF_FILE_EXN)); /* This translates to exn Size! 
  356.                        See src/compiler/Smlexc.sml */
  357.   s = alloc_string(len);
  358.   bcopy(&Byte(r[0],0), &Byte(s,0), len1);
  359.   bcopy(&Byte(r[1],0), &Byte(s,len1), len2);
  360.   Pop_roots();
  361.   return s;
  362. }
  363.  
  364. value sml_chr(v)          /* ML */
  365.      value v;
  366. {
  367.   long i;
  368.   value s;
  369.   i = Long_val(v);
  370.   if( i < 0 || i > 255 )
  371.     mlraise(Atom(SMLEXN_CHR));
  372.   s = alloc_string(1);
  373.   *(&Byte(s,0)) = (unsigned char) i;
  374.   return s;
  375. }
  376.  
  377. value sml_ord(s)          /* ML */
  378.      value s;
  379. {
  380.   long i;
  381.   if( string_length(s) == 0 )
  382.     mlraise(Atom(SMLEXN_ORD));
  383.   i = (unsigned char) *(&Byte(s,0));
  384.   return Val_long(i);
  385. }
  386.  
  387. value sml_float_of_string(s)        /* ML */
  388.      value s;
  389. {
  390.  
  391.   char buff[64];
  392.   mlsize_t len;
  393.   int i, e_len;
  394.   char c;
  395.   char *p;
  396.   double r;
  397.  
  398.   len = string_length(s);
  399.   if(len > sizeof(buff) - 1)
  400.     failwith("sml_float_of_string: argument too large");
  401.   p = String_val(s);
  402.   e_len = -1;
  403.   for (i = 0; i<len; i++) {
  404.     c = *p++;
  405.     switch( c ) {
  406.         case '~':
  407.           buff[i] = '-'; break;
  408.         case 'E':
  409.           buff[i] = 'e'; e_len = 0; break;
  410.         default:
  411.           buff[i] = c;
  412.           if( e_len >= 0 ) e_len++;
  413.           Raise_float_if( e_len > 5 )
  414.           break;
  415.     }
  416.   }
  417.   buff[len] = 0;
  418.   r = atof(buff);
  419.   if( (r > maxdouble) || (r < -maxdouble) )
  420.     failwith("sml_float_of_string: result too large");
  421.   return copy_double(r);
  422. }
  423.  
  424.  
  425. static int countChar(c, s)
  426.    int c; char* s;
  427. {
  428.   char *p; int count;
  429.  
  430.   count = 0;
  431.   for( p=s; *p != '\0'; p++ ) {
  432.     if( *p == c ) count++;
  433.   }
  434.   return count;
  435. }
  436.  
  437. /* Here we remove all '+', and replace '-' and 'e' */
  438. /* with '~' and 'E', respectively. */
  439.  
  440. static void mkSMLMinus(s)
  441.   char *s;
  442. {
  443.   char *p, *q;
  444.  
  445.   for( p=s, q=s; *p != '\0'; p++ ) {
  446.     switch( *p ) {
  447.         case '+': break;
  448.         case '-': *q++ = '~'; break;
  449.         case 'e': *q++ = 'E'; break;
  450.         default: *q++ = *p;
  451.     }
  452.   }
  453.   *q = '\0';
  454.   return;
  455. }
  456.  
  457. value sml_string_of_int(arg)      /* ML */
  458.      value arg;
  459. {
  460.   char format_buffer[32];
  461.  
  462.   sprintf(format_buffer, "%ld", Long_val(arg));
  463.   mkSMLMinus(format_buffer);
  464.   return copy_string(format_buffer);
  465. }
  466.  
  467. value sml_string_of_float(arg)    /* ML */
  468.      value arg;
  469. {
  470.   char format_buffer[64];
  471.  
  472.   sprintf(format_buffer, "%.12g", Double_val(arg));
  473.   mkSMLMinus(format_buffer);
  474.   if( countChar('.', format_buffer) == 0 &&
  475.       countChar('E', format_buffer) == 0 )
  476.     strcat(format_buffer, ".0");
  477.   return copy_string(format_buffer);
  478. }
  479.  
  480. #ifdef __MWERKS__
  481. #pragma mpwc_newline on
  482. #endif
  483.  
  484. value sml_makestring_of_char(arg)      /* ML */
  485.      value arg;
  486. {
  487.   unsigned char c;
  488.   char buff[8];
  489.  
  490.   c = Int_val(arg);
  491.   switch (c)
  492.     {
  493.     case '"':   return copy_string("#\"\\\"\"");
  494.     case '\\':  return copy_string("#\"\\\\\"");
  495.     case '\a':  return copy_string("#\"\\a\"");
  496.     case '\b':  return copy_string("#\"\\b\"");
  497.     case '\t':  return copy_string("#\"\\t\"");
  498.     case '\n':  return copy_string("#\"\\n\"");
  499.     case '\v':  return copy_string("#\"\\v\"");
  500.     case '\f':  return copy_string("#\"\\f\"");
  501.     case '\r':  return copy_string("#\"\\r\"");
  502.     default:
  503.       buff[0] = '#'; buff[1] = '"';
  504.       if( c <= 31 ) {
  505.         buff[2] = '\\'; buff[3] = '^'; buff[4] = c + 64;
  506.         buff[5] = '"'; buff[6] = 0;
  507.         return copy_string(buff);
  508.         }
  509.       else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) ) {
  510.         buff[2] = c; buff[3] = '"'; buff[4] = 0;
  511.         return copy_string(buff);
  512.         }
  513.       else {
  514.         buff[2] = '\\';
  515.         buff[3] = 48 + c / 100;
  516.         buff[4] = 48 + (c / 10) % 10;
  517.         buff[5] = 48 + c % 10;
  518.         buff[6] = '"';
  519.         buff[7] = 0;
  520.         return copy_string(buff);
  521.         }
  522.     }
  523. }
  524.  
  525. value sml_makestring_of_string(arg)      /* ML */
  526.      value arg;
  527. {
  528.   mlsize_t arg_len, len, i;
  529.   value res;
  530.   char *a; char *b;
  531.   unsigned char c;
  532.   Push_roots(r, 1);
  533.  
  534.   r[0] = arg;
  535.   arg_len = string_length(arg);
  536.  
  537.   a = String_val(r[0]);
  538.   len = 0;
  539.   for( i = 0; i < arg_len; i++ ) {
  540.     c = a[i];
  541.     switch (c)
  542.       {
  543.       case '"': case '\\': 
  544.       case '\a': case '\b': case '\t': case '\n': case '\v': 
  545.       case '\f': case '\r':
  546.         len += 2; break;
  547.       default:
  548.         if( c <= 31)
  549.           len += 3;
  550.         else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) )
  551.           len += 1;
  552.         else
  553.           len += 4;
  554.         break;
  555.       }
  556.     }
  557.  
  558.   if( (len + 2 + sizeof (value)) / sizeof (value) > Max_wosize )
  559.     failwith("sml_string_for_read: result too large");
  560.   res = alloc_string(len + 2);
  561.  
  562.   a = String_val(r[0]);
  563.   b = String_val(res);
  564.   *b++ = '"';
  565.   for( i = 0; i < arg_len; i++) {
  566.     c = a[i];
  567.     switch (c)
  568.       {
  569.       case '"':   *b++ = '\\'; *b++ = '"';  break;
  570.       case '\\':  *b++ = '\\'; *b++ = '\\'; break;
  571.       case '\a':  *b++ = '\\'; *b++ = 'a';  break;
  572.       case '\b':  *b++ = '\\'; *b++ = 'b';  break;
  573.       case '\t':  *b++ = '\\'; *b++ = 't';  break;
  574.       case '\n':  *b++ = '\\'; *b++ = 'n';  break;
  575.       case '\v':  *b++ = '\\'; *b++ = 'v';  break;
  576.       case '\f':  *b++ = '\\'; *b++ = 'f';  break;
  577.       case '\r':  *b++ = '\\'; *b++ = 'r';  break;
  578.       default:
  579.         if( c <= 31 )
  580.           { *b++ = '\\'; *b++ = '^'; *b++ = c + 64; break; }
  581.         else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) )
  582.           { *b++ = c; break; }
  583.         else
  584.           { *b++ = '\\';
  585.             *b++ = 48 + c / 100;
  586.             *b++ = 48 + (c / 10) % 10;
  587.             *b++ = 48 + c % 10;
  588.             break; }
  589.       }
  590.     }
  591.   *b++ = '"';
  592.   Pop_roots();
  593.   return res;
  594. }
  595.  
  596. #ifdef __MWERKS__
  597. #pragma mpwc_newline off
  598. #endif
  599.  
  600. /* The following must agree with timebase in mosmllib/Time.sml: */
  601.  
  602. #define TIMEBASE (-1073741824)
  603.  
  604. /* There is another problem on the Mac: with a time base of 1904,
  605.    most times are simply out of range of mosml integers. So, I added
  606.    the macros below to compensate. 07Sep95 e
  607. */
  608.  
  609. #ifdef macintosh
  610.  
  611. #if ( __MWERKS__ >= 0x1100 )
  612. // 15May97 e for MSL 2.1.1
  613. #define TMacbaseyr      1900L
  614. /* number of leap days between the two years -- MSL base was not a leap year! */
  615. #define TLpD    ((TUNIXbaseyr-TMacbaseyr)/4)
  616. #else
  617. /* 28Jan93   Kjeld & Soren */
  618. #define TMacbaseyr      1904L
  619. /* number of leap days between the two years -- Mac base was a leap year! */
  620. #define TLpD    ((TUNIXbaseyr-TMacbaseyr-1)/4) + 1
  621. #endif
  622.  
  623. #define TUNIXbaseyr     1970L
  624.  
  625. /* TimeBaseDif is the number of seconds between Mac and UNIX time (GMT) */
  626. #define TimeBaseDif     ((((TUNIXbaseyr-TMacbaseyr)*365)+TLpD)*24*60*60)
  627.  
  628. #define SYStoSMLtime(m) ((m) - TimeBaseDif)
  629. #define SMLtoSYStime(s) ((s) + TimeBaseDif)
  630.  
  631. #else
  632.  
  633. #define SYStoSMLtime
  634. #define SMLtoSYStime
  635.  
  636. #endif
  637.  
  638. value sml_getrealtime (v) /* ML */
  639.     value v;
  640. {
  641.   value res;
  642.   struct timeval tp;
  643.  
  644.   gettimeofday(&tp, NULL);
  645.   res = alloc (2, 0);
  646.   Field (res, 0) = Val_long (SYStoSMLtime(tp.tv_sec)+TIMEBASE);
  647.   Field (res, 1) = Val_long (tp.tv_usec);
  648.   return res;
  649. }
  650.  
  651. value sml_getrutime (v) /* ML */
  652.     value v;
  653. {
  654.   value res;
  655.  
  656. #if defined(__MWERKS__)
  657.   res = e_getrusage();
  658. #else
  659. #if defined(hpux) || defined(__svr4__)
  660.   struct tms buffer;
  661.  
  662.   long persec = sysconf(_SC_CLK_TCK);
  663.   times(&buffer);
  664.   res = alloc (6, 0);
  665.   Field (res, 2) = Val_long (buffer.tms_stime / persec);
  666.   Field (res, 3) = Val_long ((buffer.tms_stime % persec) * (1000000 / persec));
  667.   Field (res, 4) = Val_long (buffer.tms_utime / persec);
  668.   Field (res, 5) = Val_long ((buffer.tms_utime % persec) * (1000000 / persec));
  669. #else
  670.   struct rusage rusages;
  671.   getrusage(RUSAGE_SELF, &rusages);
  672.   res = alloc (6, 0);
  673.   Field (res, 2) = Val_long (rusages.ru_stime.tv_sec);
  674.   Field (res, 3) = Val_long (rusages.ru_stime.tv_usec);
  675.   Field (res, 4) = Val_long (rusages.ru_utime.tv_sec); 
  676.   Field (res, 5) = Val_long (rusages.ru_utime.tv_usec);
  677. #endif
  678.  
  679.   Field (res, 0) = Val_long (gc_time.tv_sec);
  680.   Field (res, 1) = Val_long (gc_time.tv_usec); 
  681. #endif
  682.  
  683.   return res;
  684. }
  685.  
  686.  
  687. value sml_errno(arg)          /* ML */
  688.      value arg;
  689. {
  690.   return Val_long(errno);
  691. }
  692.  
  693. value sml_getdir(arg)        /* ML */
  694.      value arg;
  695. {
  696.  char directory[MAXPATHLEN];
  697.  char *res;
  698.  
  699.  errno = 0;
  700.  res = getcwd(directory, MAXPATHLEN);
  701.  if (res == NULL)
  702.     failwith("getcwd");
  703.  return copy_string(directory);
  704. }
  705.  
  706. value sml_mkdir(path)          /* ML */
  707.      value path;
  708. {
  709.   if (mkdir(String_val(path), 0777) == -1) 
  710.       failwith("mkdir");
  711.   return Val_unit;
  712. }
  713.  
  714. value sml_rmdir(path)          /* ML */
  715.      value path;
  716. {
  717.   if (rmdir(String_val(path)) == -1) 
  718.       failwith("rmdir");
  719.   return Val_unit;
  720. }
  721.  
  722. value sml_opendir(path)          /* ML */
  723.      value path;
  724. { DIR * dstr;
  725.  
  726.   dstr = opendir(String_val(path));
  727.   if (dstr == NULL)
  728.       failwith("opendir");
  729. #ifdef MSDOS
  730.   if (readdir(dstr) == NULL) 
  731.       failwith("opendir");
  732.   else
  733.       rewinddir(dstr);
  734. #endif
  735.   return (value) dstr;
  736. }
  737.  
  738. value sml_rewinddir(v)          /* ML */
  739.      value v;
  740. { 
  741.   rewinddir((DIR *) v);
  742.   return Val_unit;
  743. }
  744.  
  745. value sml_readdir(v)          /* ML */
  746.      value v;
  747. { struct dirent *direntry;
  748.  
  749.   direntry = readdir((DIR *) v);
  750.   if (direntry == NULL) 
  751.       return copy_string("");
  752.   return copy_string((*direntry).d_name);
  753. }
  754.  
  755. value sml_closedir(v)          /* ML */
  756.      value v;
  757. { 
  758.   if (closedir((DIR *) v) == -1)
  759.       failwith("closedir");
  760.   return Val_unit;
  761. }
  762.  
  763. value sml_isdir(path)          /* ML */
  764.      value path;
  765. { struct stat buf;
  766.  
  767.   if (stat(String_val(path), &buf) == -1)
  768.       failwith("stat");
  769.   return (Val_bool(S_ISDIR(buf.st_mode)));
  770. }
  771.  
  772. value sml_modtime(path)          /* ML */
  773.      value path;
  774. { struct stat buf;
  775.  
  776.   if (stat(String_val(path), &buf) == -1)
  777.       failwith("stat");
  778.   return (copy_double ((double) (SYStoSMLtime(buf.st_mtime))));
  779. }
  780.  
  781. value sml_settime(path, time)          /* ML */
  782.      value path, time;
  783. { struct utimbuf tbuf;
  784.  
  785.   tbuf.actime = tbuf.modtime = SMLtoSYStime((long) (Double_val(time)));
  786.   if (utime(String_val(path), &tbuf) == -1)
  787.       failwith("utime");
  788.   return Val_unit;
  789. }
  790.  
  791. value sml_access(path, permarg)          /* ML */
  792.      value path, permarg;
  793. { long perms;
  794.   long perm = Long_val(permarg);
  795.  
  796.   perms  = ((0x1 & perm) ? R_OK : 0);
  797.   perms |= ((0x2 & perm) ? W_OK : 0);
  798.   perms |= ((0x4 & perm) ? X_OK : 0);
  799.   if (perms == 0) perms = F_OK;
  800.  
  801.   if (access(String_val(path), perms) == 0)
  802.     return Val_bool(1);
  803.   return Val_bool(0);
  804. }
  805.  
  806. #ifndef HAS_STRERROR
  807.   extern int sys_nerr;
  808.   extern char * sys_errlist [];
  809.   extern char *realpath();
  810.   char *mktemp();
  811. #endif
  812.  
  813. value sml_tmpnam(v)          /* ML */
  814.      value v;
  815. { char *res;
  816.  
  817.   res = tmpnam(NULL);
  818.   if (res == NULL) 
  819.     failwith("tmpnam");  
  820.   return copy_string(res);
  821. }
  822.  
  823. value sml_errormsg(err)   /* ML */
  824.      value err;
  825. {
  826.   int errnum;
  827.   errnum = Long_val(err);
  828. #ifdef HAS_STRERROR
  829.   return copy_string(strerror(errnum));
  830. #else
  831.   if (errnum < 0 || errnum >= sys_nerr) 
  832.       return copy_string("(Unknown error)");
  833.   else 
  834.     return copy_string(sys_errlist[errnum]);
  835. #endif
  836. }
  837.  
  838. value sml_asin(f)           /* ML */
  839.      value f;
  840. { double r = Double_val(f);
  841.   float_exn = SMLEXN_DOMAIN;
  842.   Raise_float_if( r < -1.0 || r > 1.0 );  
  843.   r = asin(r);
  844.   Raise_float_if( r != r );
  845.   return copy_double(r);
  846. }
  847.  
  848. value sml_acos(f)           /* ML */
  849.      value f;
  850. { double r = Double_val(f);
  851.   float_exn = SMLEXN_DOMAIN;
  852.   Raise_float_if( r < -1.0 || r > 1.0 );  
  853.   r = acos(r);
  854.   Raise_float_if( r != r );
  855.   return copy_double(r);
  856. }
  857.  
  858. value sml_atan2(f1, f2)           /* ML */
  859.      value f1, f2;
  860. { double r, r1, r2;
  861.   float_exn = SMLEXN_DOMAIN;
  862.   r1 = Double_val(f1);
  863.   r2 = Double_val(f2);
  864.   if (r1 == 0.0 && r2 == 0.0) 
  865.     return copy_double(0.0);
  866.   r = atan2(r1, r2);
  867.   Check_float(r);
  868.   Raise_float_if( r != r );
  869.   return copy_double(r);
  870. }
  871.  
  872. value sml_pow(f1, f2)           /* ML */
  873.      value f1, f2;
  874. { double r, r1, r2;
  875.   float_exn = SMLEXN_DOMAIN;
  876.   r1 = Double_val(f1);
  877.   r2 = Double_val(f2);
  878.   if (r1 == 0.0 && r2 == 0.0) 
  879.     return copy_double(1.0);
  880.   if (   (r1 == 0.0 && r2 < 0.0) 
  881.       || (r1 < 0.0 && (   fabs(r2) > (double) (Max_long) 
  882.                || r2 != (double)(long)r2)))
  883.     mlraise(Atom(float_exn));
  884.   r = pow(r1, r2);
  885.   float_exn = SMLEXN_OVF;
  886.   Check_float(r);
  887.   float_exn = SMLEXN_DOMAIN;
  888.   Raise_float_if( r != r );
  889.   return copy_double(r);
  890. }
  891.  
  892. value sml_localtime (v) /* ML */
  893.     value v;
  894. {
  895.   value res;
  896.   struct tm *tmr;
  897.   time_t clock = SMLtoSYStime((long) (Double_val(v)));
  898.   tmr = localtime(&clock);
  899.   res = alloc (9, 0);
  900.   Field (res, 0) = Val_long ((*tmr).tm_hour);
  901.   Field (res, 1) = Val_long ((*tmr).tm_isdst);
  902.   Field (res, 2) = Val_long ((*tmr).tm_mday);
  903.   Field (res, 3) = Val_long ((*tmr).tm_min); 
  904.   Field (res, 4) = Val_long ((*tmr).tm_mon);
  905.   Field (res, 5) = Val_long ((*tmr).tm_sec);
  906.   Field (res, 6) = Val_long ((*tmr).tm_wday);
  907.   Field (res, 7) = Val_long ((*tmr).tm_yday);
  908.   Field (res, 8) = Val_long ((*tmr).tm_year);
  909.  
  910.   return res;
  911. }
  912.  
  913. value sml_gmtime (v) /* ML */
  914.     value v;
  915. {
  916.   value res;
  917.   struct tm *tmr;
  918.   time_t clock = SMLtoSYStime((long) (Double_val(v)));
  919.   tmr = gmtime(&clock);
  920.   res = alloc (9, 0);
  921.   Field (res, 0) = Val_long ((*tmr).tm_hour);
  922.   Field (res, 1) = Val_long ((*tmr).tm_isdst);
  923.   Field (res, 2) = Val_long ((*tmr).tm_mday);
  924.   Field (res, 3) = Val_long ((*tmr).tm_min); 
  925.   Field (res, 4) = Val_long ((*tmr).tm_mon);
  926.   Field (res, 5) = Val_long ((*tmr).tm_sec);
  927.   Field (res, 6) = Val_long ((*tmr).tm_wday);
  928.   Field (res, 7) = Val_long ((*tmr).tm_yday);
  929.   Field (res, 8) = Val_long ((*tmr).tm_year);
  930.   return res;
  931. }
  932.  
  933. value sml_mktime (v) /* ML */
  934.     value v;
  935. {
  936.   struct tm tmr;
  937.  
  938.   tmr.tm_hour  = Long_val(Field (v, 0));
  939.   tmr.tm_isdst = Long_val(Field (v, 1));
  940.   tmr.tm_mday  = Long_val(Field (v, 2));
  941.   tmr.tm_min   = Long_val(Field (v, 3));
  942.   tmr.tm_mon   = Long_val(Field (v, 4));
  943.   tmr.tm_sec   = Long_val(Field (v, 5));
  944.   tmr.tm_wday  = Long_val(Field (v, 6));
  945.   tmr.tm_yday  = Long_val(Field (v, 7));
  946.   tmr.tm_year  = Long_val(Field (v, 8));
  947.  
  948.   return copy_double((double)SYStoSMLtime(tm2cal(&tmr)));
  949.  
  950. }
  951.  
  952. value sml_asctime (v) /* ML */
  953.     value v;
  954. {
  955.   struct tm tmr;
  956.   char *res;
  957.  
  958.   tmr.tm_hour  = Long_val(Field (v, 0));
  959.   tmr.tm_isdst = Long_val(Field (v, 1));
  960.   tmr.tm_mday  = Long_val(Field (v, 2));
  961.   tmr.tm_min   = Long_val(Field (v, 3));
  962.   tmr.tm_mon   = Long_val(Field (v, 4));
  963.   tmr.tm_sec   = Long_val(Field (v, 5));
  964.   tmr.tm_wday  = Long_val(Field (v, 6));
  965.   tmr.tm_yday  = Long_val(Field (v, 7));
  966.   tmr.tm_year  = Long_val(Field (v, 8));
  967.  
  968.   tm2cal(&tmr);
  969.  
  970.   res = asctime(&tmr);
  971.   if (res == NULL) 
  972.       failwith("asctime");
  973.   return copy_string(res);
  974. }
  975.  
  976. value sml_strftime (fmt, v) /* ML */
  977.     value fmt, v;
  978. {
  979.   struct tm tmr;
  980. #define BUFSIZE 256      
  981.   char buf[BUFSIZE];
  982.   long ressize;
  983.  
  984.   tmr.tm_hour  = Long_val(Field (v, 0));
  985.   tmr.tm_isdst = Long_val(Field (v, 1));
  986.   tmr.tm_mday  = Long_val(Field (v, 2));
  987.   tmr.tm_min   = Long_val(Field (v, 3));
  988.   tmr.tm_mon   = Long_val(Field (v, 4));
  989.   tmr.tm_sec   = Long_val(Field (v, 5));
  990.   tmr.tm_wday  = Long_val(Field (v, 6));
  991.   tmr.tm_yday  = Long_val(Field (v, 7));
  992.   tmr.tm_year  = Long_val(Field (v, 8));
  993.  
  994.   tm2cal(&tmr);
  995.  
  996.   ressize = strftime(buf, BUFSIZE, String_val(fmt), &tmr);
  997.   if (ressize == 0 || ressize == BUFSIZE) 
  998.       failwith("strftime");
  999.   return copy_string(buf);
  1000. #undef BUFSIZE
  1001. }
  1002.  
  1003. value sml_general_string_of_float(fmt, arg)    /* ML */
  1004.      value fmt, arg;
  1005. {
  1006. #define BUFSIZE 512
  1007.   char format_buffer[BUFSIZE];
  1008.   int i;
  1009.  
  1010.   /* Unfortunately there seems to be no way to ensure that this does not
  1011.    * crash by overflowing the format_buffer (e.g. when specifying a huge 
  1012.    * number of decimal digits in the fixed-point format): 
  1013.    */
  1014.  
  1015.   sprintf(format_buffer, String_val(fmt), Double_val(arg));
  1016.  
  1017.   mkSMLMinus(format_buffer);
  1018.   return copy_string(format_buffer);
  1019. #undef BUFSIZE
  1020. }
  1021.  
  1022. value sml_filesize(path)          /* ML */
  1023.      value path;
  1024. { struct stat buf;
  1025.  
  1026.   if (stat(String_val(path), &buf) == -1)
  1027.       failwith("stat");
  1028.   return (Val_long (buf.st_size));
  1029. }
  1030.  
  1031. value sml_int_of_hex(s)          /* ML */
  1032.      value s;
  1033. { value v;
  1034.   long res;
  1035.   int sign;
  1036.   char * p;
  1037.  
  1038.   /* The argument s has form [~]?0x[0-9a-fA-F]+ */
  1039.  
  1040.   p = String_val(s);
  1041.   sign = 1;
  1042.   if (*p == '~') {
  1043.     sign = -1;
  1044.     p++;
  1045.   }
  1046.   /* skip 0x in s */
  1047.   p += 2; 
  1048.  
  1049.   res = sign * scanhex(p, (unsigned long)Min_long);
  1050.   v = Val_long(res);
  1051.   if( Long_val(v) != res )
  1052.     goto raise_failure;
  1053.   return v;
  1054.  
  1055.   raise_failure:
  1056.     failwith("sml_int_of_hex");
  1057. }
  1058.  
  1059. value sml_word_of_hex(s)          /* ML */
  1060.      value s;
  1061. { value v;
  1062.   long res;
  1063.   char * p;
  1064.  
  1065.   /* The argument s has form 0wx[0-9a-fA-F]+ */
  1066.  
  1067.   p = String_val(s);
  1068.   /* skip 0wx in s */
  1069.   p += 3; 
  1070.  
  1071.   res = scanhex(p, 2 * (unsigned long)Min_long);
  1072.   v = Val_long((long)res);
  1073.   return v;
  1074. }
  1075.  
  1076. value sml_word_of_dec(s)          /* ML */
  1077.      value s;
  1078. { value v;
  1079.   long res;
  1080.   char * p;
  1081.  
  1082.   /* The argument s has form 0w[0-9]+ */
  1083.   p = String_val(s);
  1084.   /* skip 0w in s */
  1085.   p += 2; 
  1086.  
  1087.   res = (long)scandec(p, 2 * (unsigned long)Min_long);
  1088.   v = Val_long((long)res);
  1089.   return v;
  1090. }
  1091.  
  1092. value sml_hexstring_of_word(arg)      /* ML */
  1093.      value arg;
  1094. {
  1095.   char format_buffer[32];
  1096.  
  1097.   sprintf(format_buffer, "0wx%lX", Long_val((unsigned long)arg));
  1098.   return copy_string(format_buffer);
  1099. }
  1100.  
  1101. value sml_sinh(f)         /* ML */
  1102.      value f;
  1103. { double r;
  1104.   float_exn = SMLEXN_OVF;  
  1105.   r = Double_val(f);
  1106.   r = sinh(r);
  1107.   Check_float(r);
  1108.   return copy_double(r);
  1109. }
  1110.  
  1111. value sml_cosh(f)         /* ML */
  1112.      value f;
  1113. { double r;
  1114.   float_exn = SMLEXN_OVF;
  1115.   r = Double_val(f);
  1116.   r = cosh(r);
  1117.   Check_float(r);
  1118.   return copy_double(r);
  1119. }
  1120.  
  1121. value sml_tanh(f)         /* ML */
  1122.      value f;
  1123. { double r;
  1124.   float_exn = SMLEXN_DOMAIN;
  1125.   r = Double_val(f);
  1126.   r = tanh(r);
  1127.   Check_float(r);
  1128.   return copy_double(r);
  1129. }
  1130.  
  1131.